home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / buffer.lisp < prev    next >
Lisp/Scheme  |  1992-04-22  |  65KB  |  1,800 lines
  1. ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
  2.  
  3. ;;; This file contains definitions for the BUFFER object for Common-Lisp X
  4. ;;; windows version 11
  5.  
  6. ;;;
  7. ;;;             TEXAS INSTRUMENTS INCORPORATED
  8. ;;;                  P.O. BOX 2909
  9. ;;;                   AUSTIN, TEXAS 78769
  10. ;;;
  11. ;;; Copyright (C) 1987 Texas Instruments Incorporated.
  12. ;;;
  13. ;;; Permission is granted to any individual or institution to use, copy, modify,
  14. ;;; and distribute this software, provided that this complete copyright and
  15. ;;; permission notice is maintained, intact, in all copies and supporting
  16. ;;; documentation.
  17. ;;;
  18. ;;; Texas Instruments Incorporated provides this software "as is" without
  19. ;;; express or implied warranty.
  20. ;;;
  21.  
  22. ;; A few notes:
  23. ;;
  24. ;;  1. The BUFFER implements a two-way buffered byte / half-word
  25. ;;     / word stream.  Hooks are left for implementing this with a
  26. ;;     shared memory buffer, or with effenciency hooks to the network
  27. ;;     code.
  28. ;;
  29. ;;  2. The BUFFER object uses overlapping displaced arrays for
  30. ;;     inserting and removing bytes half-words and words.
  31. ;;
  32. ;;  3. The BYTE component of these arrays is written to a STREAM
  33. ;;     associated with the BUFFER.  The stream has its own buffer.
  34. ;;     This may be made more efficient by using the Zetalisp
  35. ;;     :Send-Output-Buffer operation.
  36. ;;
  37. ;;  4. The BUFFER object is INCLUDED in the DISPLAY object.
  38. ;;     This was done to reduce access time when sending requests,
  39. ;;     while maintaing some code modularity.
  40. ;;     Several buffer functions are duplicated (with-buffer,
  41. ;;     buffer-force-output, close-buffer) to keep the naming
  42. ;;     conventions consistent.
  43. ;;
  44. ;;  5. A nother layer of software is built on top of this for generating
  45. ;;     both client and server interface routines, given a specification
  46. ;;     of the protocol. (see the INTERFACE file)
  47. ;;
  48. ;;  6. Care is taken to leave the buffer pointer (buffer-bbuf) set to
  49. ;;     a point after a complete request.  This is to ensure that a partial
  50. ;;     request won't be left after aborts (e.g. control-abort on a lispm).
  51.  
  52. (in-package :xlib)
  53.  
  54. (defconstant *requestsize* 160) ;; Max request size (excluding variable length requests)
  55.  
  56. ;;; This is here instead of in bufmac so that with-display can be
  57. ;;; compiled without macros and bufmac being loaded.
  58.  
  59. (defmacro with-buffer ((buffer &key timeout inline)
  60.                &body body &environment env)
  61.   ;; This macro is for use in a multi-process environment.  It provides
  62.   ;; exclusive access to the local buffer object for request generation and
  63.   ;; reply processing.
  64.   `(macrolet ((with-buffer ((buffer &key timeout) &body body)
  65.         ;; Speedup hack for lexically nested with-buffers
  66.         `(progn
  67.            (progn ,buffer ,@(and timeout `(,timeout)) nil)
  68.            ,@body)))
  69.      ,(if (and (null inline) (macroexpand '(use-closures) env))
  70.       `(flet ((.with-buffer-body. () ,@body))
  71.          #+clx-ansi-common-lisp
  72.          (declare (dynamic-extent #'.with-buffer-body.))
  73.          (with-buffer-function ,buffer ,timeout #'.with-buffer-body.))
  74.     (let ((buf (if (or (symbolp buffer) (constantp buffer))
  75.                buffer
  76.              '.buffer.)))
  77.       `(let (,@(unless (eq buf buffer) `((,buf ,buffer))))
  78.          ,@(unless (eq buf buffer) `((declare (type buffer ,buf))))
  79.          ,(declare-bufmac)
  80.          (when (buffer-dead ,buf)
  81.            (x-error 'closed-display :display ,buf))
  82.          (holding-lock ((buffer-lock ,buf) ,buf "CLX Display Lock"
  83.                 ,@(and timeout `(:timeout ,timeout)))
  84.            ,@body))))))
  85.  
  86. (defun with-buffer-function (buffer timeout function)
  87.   (declare (type display buffer)
  88.        (type (or null number) timeout)
  89.        (type function function)
  90.        #+clx-ansi-common-lisp
  91.        (dynamic-extent function)
  92.        #+(and lispm (not clx-ansi-common-lisp))
  93.        (sys:downward-funarg function))
  94.   (with-buffer (buffer :timeout timeout :inline t)
  95.     (funcall function)))
  96.  
  97. ;;; The following are here instead of in bufmac so that event-case can
  98. ;;; be compiled without macros and bufmac being loaded.
  99.  
  100. (defmacro read-card8 (byte-index)
  101.   `(aref-card8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  102.  
  103. (defmacro read-int8 (byte-index)
  104.   `(aref-int8 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  105.  
  106. (defmacro read-card16 (byte-index)
  107.   #+clx-overlapping-arrays
  108.   `(aref-card16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  109.   #-clx-overlapping-arrays
  110.   `(aref-card16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  111.  
  112. (defmacro read-int16 (byte-index)
  113.   #+clx-overlapping-arrays
  114.   `(aref-int16 buffer-wbuf (index+ buffer-woffset (index-ash ,byte-index -1)))
  115.   #-clx-overlapping-arrays
  116.   `(aref-int16 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  117.  
  118. (defmacro read-card32 (byte-index)
  119.   #+clx-overlapping-arrays
  120.   `(aref-card32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  121.   #-clx-overlapping-arrays
  122.   `(aref-card32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  123.  
  124. (defmacro read-int32 (byte-index)
  125.   #+clx-overlapping-arrays
  126.   `(aref-int32 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  127.   #-clx-overlapping-arrays
  128.   `(aref-int32 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  129.  
  130. (defmacro read-card29 (byte-index)
  131.   #+clx-overlapping-arrays
  132.   `(aref-card29 buffer-lbuf (index+ buffer-loffset (index-ash ,byte-index -2)))
  133.   #-clx-overlapping-arrays
  134.   `(aref-card29 buffer-bbuf (index+ buffer-boffset ,byte-index)))
  135.  
  136. (defmacro event-code (reply-buffer)
  137.   ;; The reply-buffer structure is used for events.
  138.   ;; The size slot is used for the event code.
  139.   `(reply-size ,reply-buffer))
  140.  
  141. (defmacro reading-event ((event &rest options) &body body)
  142.   (declare (arglist (buffer &key sizes) &body body))
  143.   ;; BODY may contain calls to (READ32 &optional index) etc.
  144.   ;; These calls will read from the input buffer at byte
  145.   ;; offset INDEX.  If INDEX is not supplied, then the next
  146.   ;; word, half-word or byte is returned.
  147.   `(with-buffer-input (,event ,@options) ,@body))
  148.  
  149. (defmacro with-buffer-input ((reply-buffer &key display (sizes '(8 16 32)) index)
  150.                  &body body)
  151.   (unless (listp sizes) (setq sizes (list sizes)))
  152.   ;; 160 is a special hack for client-message-events
  153.   (when (set-difference sizes '(0 8 16 32 160 256))
  154.     (error "Illegal sizes in ~a" sizes))
  155.   `(let ((%reply-buffer ,reply-buffer)
  156.      ,@(and display `((%buffer ,display))))
  157.      (declare (type reply-buffer %reply-buffer)
  158.           ,@(and display '((type display %buffer))))
  159.      ,(declare-bufmac)
  160.      ,@(and display '(%buffer))
  161.      (let* ((buffer-boffset (the array-index ,(or index 0)))
  162.         #-clx-overlapping-arrays
  163.         (buffer-bbuf (reply-ibuf8 %reply-buffer))
  164.         #+clx-overlapping-arrays
  165.         ,@(append
  166.         (when (member 8 sizes)
  167.           `((buffer-bbuf (reply-ibuf8 %reply-buffer))))
  168.         (when (or (member 16 sizes) (member 160 sizes))
  169.           `((buffer-woffset (index-ash buffer-boffset -1))
  170.             (buffer-wbuf (reply-ibuf16 %reply-buffer))))
  171.         (when (member 32 sizes)
  172.           `((buffer-loffset (index-ash buffer-boffset -2))
  173.             (buffer-lbuf (reply-ibuf32 %reply-buffer))))))
  174.        (declare (type array-index buffer-boffset))
  175.        #-clx-overlapping-arrays
  176.        (declare (type buffer-bytes buffer-bbuf)
  177.         (array-register buffer-bbuf))
  178.        #+clx-overlapping-arrays
  179.        ,@(append
  180.        (when (member 8 sizes)
  181.          '((declare (type buffer-bytes buffer-bbuf)
  182.             (array-register buffer-bbuf))))
  183.        (when (member 16 sizes)
  184.          '((declare (type array-index buffer-woffset))
  185.            (declare (type buffer-words buffer-wbuf)
  186.             (array-register buffer-wbuf))))
  187.        (when (member 32 sizes)
  188.          '((declare (type array-index buffer-loffset))
  189.            (declare (type buffer-longs buffer-lbuf)
  190.             (array-register buffer-lbuf)))))
  191.        buffer-boffset
  192.        #-clx-overlapping-arrays
  193.        buffer-bbuf
  194.        #+clx-overlapping-arrays
  195.        ,@(append
  196.        (when (member 8  sizes) '(buffer-bbuf))
  197.        (when (member 16 sizes) '(buffer-woffset buffer-wbuf))
  198.        (when (member 32 sizes) '(buffer-loffset buffer-lbuf)))
  199.        #+clx-overlapping-arrays
  200.        (macrolet ((%buffer-sizes () ',sizes))
  201.      ,@body)
  202.        #-clx-overlapping-arrays
  203.        ,@body)))
  204.  
  205. (defun make-buffer (output-size constructor &rest options)
  206.   (declare (dynamic-extent options))
  207.   ;; Output-Size is the output-buffer size in bytes.
  208.   (let ((byte-output (make-array output-size :element-type 'card8
  209.                  :initial-element 0)))
  210.     (apply constructor
  211.        :size output-size
  212.        :obuf8 byte-output
  213.        #+clx-overlapping-arrays
  214.        :obuf16
  215.        #+clx-overlapping-arrays
  216.        (make-array (index-ash output-size -1)
  217.                :element-type 'overlap16
  218.                :displaced-to byte-output)
  219.        #+clx-overlapping-arrays
  220.        :obuf32
  221.        #+clx-overlapping-arrays
  222.        (make-array (index-ash output-size -2)
  223.                :element-type 'overlap32
  224.                :displaced-to byte-output)
  225.        options))) 
  226.  
  227. (defun make-reply-buffer (size)
  228.   ;; Size is the buffer size in bytes
  229.   (let ((byte-input (make-array size :element-type 'card8
  230.                 :initial-element 0)))
  231.     (make-reply-buffer-internal
  232.       :size size
  233.       :ibuf8 byte-input
  234.       #+clx-overlapping-arrays
  235.       :ibuf16
  236.       #+clx-overlapping-arrays
  237.       (make-array (index-ash size -1)
  238.           :element-type 'overlap16
  239.           :displaced-to byte-input)
  240.       #+clx-overlapping-arrays
  241.       :ibuf32
  242.       #+clx-overlapping-arrays
  243.       (make-array (index-ash size -2)
  244.           :element-type 'overlap32
  245.           :displaced-to byte-input))))
  246.  
  247. (defun buffer-ensure-size (buffer size)
  248.   (declare (type buffer buffer)
  249.        (type array-index size))
  250.   (when (index> size (buffer-size buffer))
  251.     (with-buffer (buffer)
  252.       (buffer-flush buffer)
  253.       (let* ((new-buffer-size (index-ash 1 (integer-length (index1- size))))
  254.          (new-buffer (make-array new-buffer-size :element-type 'card8
  255.                      :initial-element 0)))
  256.     (setf (buffer-obuf8 buffer) new-buffer)
  257.     #+clx-overlapping-arrays
  258.     (setf (buffer-obuf16 buffer)
  259.           (make-array (index-ash new-buffer-size -1)
  260.               :element-type 'overlap16
  261.               :displaced-to new-buffer)
  262.           (buffer-obuf32 buffer)
  263.           (make-array (index-ash new-buffer-size -2)
  264.               :element-type 'overlap32
  265.               :displaced-to new-buffer))))))
  266.  
  267. (defun buffer-pad-request (buffer pad)
  268.   (declare (type buffer buffer)
  269.        (type array-index pad))
  270.   (unless (index-zerop pad)
  271.     (when (index> (index+ (buffer-boffset buffer) pad)
  272.           (buffer-size buffer))
  273.       (buffer-flush buffer))
  274.     (incf (buffer-boffset buffer) pad)
  275.     (unless (index-zerop (index-mod (buffer-boffset buffer) 4))
  276.       (buffer-flush buffer))))
  277.  
  278. (declaim (inline buffer-new-request-number))
  279.  
  280. #-akcl
  281. (defun buffer-new-request-number (buffer)
  282.   (declare (type buffer buffer))
  283.   (setf (buffer-request-number buffer)
  284.     (ldb (byte 16 0) (1+ (buffer-request-number buffer)))))
  285.  
  286. #+akcl
  287. (defun buffer-new-request-number (buffer)
  288.   (declare (type buffer buffer))
  289.   (setf (buffer-request-number buffer)
  290.     (logand #xffff (the card29 (1+ (the card29(buffer-request-number buffer)))))))
  291.  
  292. (defun with-buffer-request-function (display gc-force request-function)
  293.   (declare (type display display)
  294.        (type (or null gcontext) gc-force))
  295.   (declare (type function request-function)
  296.        #+clx-ansi-common-lisp
  297.        (dynamic-extent request-function)
  298.        #+(and lispm (not clx-ansi-common-lisp))
  299.        (sys:downward-funarg request-function))
  300.   (with-buffer (display :inline t)
  301.     (multiple-value-prog1
  302.       (progn
  303.     (when gc-force (force-gcontext-changes-internal gc-force))
  304.     (without-aborts (funcall request-function display)))
  305.       (display-invoke-after-function display))))
  306.  
  307. (defun with-buffer-request-function-nolock (display gc-force request-function)
  308.   (declare (type display display)
  309.        (type (or null gcontext) gc-force))
  310.   (declare (type function request-function)
  311.        #+clx-ansi-common-lisp
  312.        (dynamic-extent request-function)
  313.        #+(and lispm (not clx-ansi-common-lisp))
  314.        (sys:downward-funarg request-function))
  315.   (multiple-value-prog1
  316.     (progn
  317.       (when gc-force (force-gcontext-changes-internal gc-force))
  318.       (without-aborts (funcall request-function display)))
  319.     (display-invoke-after-function display)))
  320.  
  321. (defstruct (pending-command (:copier nil) (:predicate nil))
  322.   (sequence 0 :type card16)
  323.   (reply-buffer nil :type (or null reply-buffer))
  324.   (process nil)
  325.   (next nil #-explorer :type #-explorer (or null pending-command)))
  326.  
  327. (defun with-buffer-request-and-reply-function
  328.        (display multiple-reply request-function reply-function)
  329.   (declare (type display display)
  330.        (type boolean multiple-reply))
  331.   (declare (type function request-function reply-function)
  332.        #+clx-ansi-common-lisp
  333.        (dynamic-extent request-function reply-function)
  334.        #+(and lispm (not clx-ansi-common-lisp))
  335.        (sys:downward-funarg request-function reply-function))
  336.   (let ((pending-command nil)
  337.     (reply-buffer nil))
  338.     (declare (type (or null pending-command) pending-command)
  339.          (type (or null reply-buffer) reply-buffer))
  340.     (unwind-protect
  341.     (progn 
  342.       (with-buffer (display :inline t)
  343.         (setq pending-command (start-pending-command display))
  344.         (without-aborts (funcall request-function display))
  345.         (buffer-force-output display)
  346.         (display-invoke-after-function display))
  347.       (cond (multiple-reply
  348.          (loop
  349.            (setq reply-buffer (read-reply display pending-command))
  350.            (when (funcall reply-function display reply-buffer) (return nil))
  351.            (deallocate-reply-buffer (shiftf reply-buffer nil))))
  352.         (t
  353.          (setq reply-buffer (read-reply display pending-command))
  354.          (funcall reply-function display reply-buffer))))
  355.       (when reply-buffer (deallocate-reply-buffer reply-buffer))
  356.       (when pending-command (stop-pending-command display pending-command)))))
  357.  
  358. ;;
  359. ;; Buffer stream operations
  360. ;;
  361.  
  362. (defun buffer-write (vector buffer start end)
  363.   ;; Write out VECTOR from START to END into BUFFER
  364.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  365.   (declare (type buffer buffer)
  366.        (type array-index start end))
  367.   (when (buffer-dead buffer)
  368.     (x-error 'closed-display :display buffer))
  369.   (wrap-buf-output (buffer)
  370.     (funcall (buffer-write-function buffer) vector buffer start end))
  371.   nil)
  372.  
  373. (defun buffer-flush (buffer)
  374.   ;; Write the buffer contents to the server stream - doesn't force-output the stream
  375.   ;; Internal function, MUST BE CALLED FROM WITHIN WITH-BUFFER
  376.   (declare (type buffer buffer))
  377.   (unless (buffer-flush-inhibit buffer)
  378.     (let ((boffset (buffer-boffset buffer)))
  379.       (declare (type array-index boffset))
  380.       (when (index-plusp boffset)
  381.     (buffer-write (buffer-obuf8 buffer) buffer 0 boffset)
  382.     (setf (buffer-boffset buffer) 0)
  383.     (setf (buffer-last-request buffer) nil))))
  384.   nil)
  385.  
  386. (defmacro with-buffer-flush-inhibited ((buffer) &body body)
  387.   (let ((buf (if (or (symbolp buffer) (constantp buffer)) buffer '.buffer.)))
  388.     `(let* (,@(and (not (eq buf buffer)) `((,buf ,buffer)))
  389.         (.saved-buffer-flush-inhibit. (buffer-flush-inhibit ,buf)))
  390.        (unwind-protect
  391.        (progn
  392.          (setf (buffer-flush-inhibit ,buf) t)
  393.          ,@body)
  394.      (setf (buffer-flush-inhibit ,buf) .saved-buffer-flush-inhibit.)))))
  395.  
  396. (defun buffer-force-output (buffer)
  397.   ;; Output is normally buffered, this forces any buffered output to the server.
  398.   (declare (type buffer buffer))
  399.   (when (buffer-dead buffer)
  400.     (x-error 'closed-display :display buffer))
  401.   (buffer-flush buffer)
  402.   (wrap-buf-output (buffer)
  403.     (without-aborts
  404.       (funcall (buffer-force-output-function buffer) buffer)))
  405.   nil)
  406.  
  407. (defun close-buffer (buffer &key abort)
  408.   ;; Close the host connection in BUFFER
  409.   (declare (type buffer buffer))
  410.   (unless (null (buffer-output-stream buffer))
  411.     (wrap-buf-output (buffer)
  412.       (funcall (buffer-close-function buffer) buffer :abort abort))
  413.     (setf (buffer-dead buffer) t)
  414.     ;; Zap pointers to the streams, to ensure they're GC'd
  415.     (setf (buffer-output-stream buffer) nil)
  416.     (setf (buffer-input-stream buffer) nil)
  417.     )
  418.   nil)
  419.  
  420. (defun buffer-input  (buffer vector start end &optional timeout)
  421.   ;; Read into VECTOR from the buffer stream
  422.   ;; Timeout, when non-nil, is in seconds
  423.   ;; Returns non-nil if EOF encountered
  424.   ;; Returns :TIMEOUT when timeout exceeded
  425.   (declare (type buffer buffer)
  426.        (type vector vector)
  427.        (type array-index start end)
  428.        (type (or null number) timeout))
  429.   (declare (values eof-p))
  430.   (when (buffer-dead buffer)
  431.     (x-error 'closed-display :display buffer))
  432.   (unless (= start end)
  433.     (let ((result
  434.         (wrap-buf-input (buffer)
  435.           (funcall (buffer-input-function buffer)
  436.                buffer vector start end timeout))))
  437.       (unless (or (null result) (eq result :timeout))
  438.     (close-buffer buffer))
  439.       result)))
  440.  
  441. (defun buffer-input-wait  (buffer timeout)
  442.   ;; Timeout, when non-nil, is in seconds
  443.   ;; Returns non-nil if EOF encountered
  444.   ;; Returns :TIMEOUT when timeout exceeded
  445.   (declare (type buffer buffer)
  446.        (type (or null number) timeout))
  447.   (declare (values timeout))
  448.   (when (buffer-dead buffer)
  449.     (x-error 'closed-display :display buffer))
  450.   (let ((result
  451.       (wrap-buf-input (buffer)
  452.         (funcall (buffer-input-wait-function buffer)
  453.              buffer timeout))))
  454.     (unless (or (null result) (eq result :timeout))
  455.       (close-buffer buffer))
  456.     result))
  457.  
  458. (defun buffer-listen (buffer)
  459.   ;; Returns T if there is input available for the buffer. This should never
  460.   ;; block, so it can be called from the scheduler.
  461.   (declare (type buffer buffer))
  462.   (declare (values input-available))
  463.   (or (not (null (buffer-dead buffer)))
  464.       (wrap-buf-input (buffer)
  465.     (funcall (buffer-listen-function buffer) buffer))))
  466.  
  467. ;;; Reading sequences of strings
  468.  
  469. ;;; a list of pascal-strings with card8 lengths, no padding in between
  470. ;;; can't use read-sequence-char
  471. (defun read-sequence-string (buffer-bbuf length nitems result-type
  472.                  &optional (buffer-boffset 0))
  473.   (declare (type buffer-bytes buffer-bbuf)
  474.        (type array-index length nitems buffer-boffset))
  475.   length
  476.   (with-vector (buffer-bbuf buffer-bytes)
  477.     (let ((result (make-sequence result-type nitems)))
  478.       (do* ((index 0 (index+ index 1 string-length))
  479.         (count 0 (index1+ count))
  480.         (string-length 0)
  481.         (string ""))
  482.        ((index>= count nitems)
  483.         result)
  484.     (declare (type array-index index count string-length)
  485.          (type string string))
  486.     (setq string-length (read-card8 index)
  487.           string (make-sequence 'string string-length))
  488.     (do ((i (index1+ index) (index1+ i))
  489.          (j 0 (index1+ j)))
  490.         ((index>= j string-length)
  491.          (setf (elt result count) string))
  492.       (declare (type array-index i j))
  493.       (setf (aref string j) (card8->char (read-card8 i))))))))
  494.  
  495. ;;; Reading sequences of chars
  496.  
  497. (defun read-sequence-char (reply-buffer result-type nitems &optional transform data
  498.                (start 0) (index 0))
  499.   (declare (type reply-buffer reply-buffer)
  500.        (type t result-type) ;; CL type
  501.        (type array-index nitems start index)
  502.        (type (or null sequence) data))
  503.   (declare (type (or null (function (character) t)) transform)
  504.        #+clx-ansi-common-lisp
  505.        (dynamic-extent transform)
  506.        #+(and lispm (not clx-ansi-common-lisp))
  507.        (sys:downward-funarg transform))
  508.   (if transform 
  509.       (flet ((card8->char->transform (v)
  510.            (declare (type card8 v))
  511.            (funcall transform (card8->char v))))
  512.     #+clx-ansi-common-lisp
  513.     (declare (dynamic-extent #'card8->char->transform))
  514.     (read-sequence-card8
  515.       reply-buffer result-type nitems #'card8->char->transform
  516.       data start index))
  517.     (read-sequence-card8
  518.       reply-buffer result-type nitems #'card8->char
  519.       data start index)))
  520.  
  521. ;;; Reading sequences of card8's
  522.  
  523. (defun read-list-card8 (reply-buffer nitems data start index)
  524.   (declare (type reply-buffer reply-buffer)
  525.        (type array-index nitems start index)
  526.        (type list data))
  527.   (with-buffer-input (reply-buffer :sizes (8) :index index)
  528.     (do* ((j nitems (index- j 1))
  529.       (lst (nthcdr start data)  (cdr lst))
  530.       (index 0 (index+ index 1)))
  531.      ((index-zerop j))
  532.       (declare (type array-index j index)
  533.            (type cons lst))
  534.       (setf (car lst) (read-card8 index)))))
  535.  
  536. (defun read-list-card8-with-transform (reply-buffer nitems data transform start index)
  537.   (declare (type reply-buffer reply-buffer)
  538.        (type array-index nitems start index)
  539.        (type list data))
  540.   (declare (type (function (card8) t) transform)
  541.        #+clx-ansi-common-lisp
  542.        (dynamic-extent transform)
  543.        #+(and lispm (not clx-ansi-common-lisp))
  544.        (sys:downward-funarg transform))
  545.   (with-buffer-input (reply-buffer :sizes (8) :index index)
  546.     (do* ((j nitems (index- j 1))
  547.       (lst (nthcdr start data) (cdr lst))
  548.       (index 0 (index+ index 1)))
  549.      ((index-zerop j))
  550.       (declare (type array-index j index)
  551.            (type cons lst))
  552.       (setf (car lst) (funcall transform (read-card8 index))))))
  553.  
  554. #-lispm
  555. (defun read-simple-array-card8 (reply-buffer nitems data start index)
  556.   (declare (type reply-buffer reply-buffer)
  557.        (type array-index nitems start index)
  558.        (type (simple-array card8 (*)) data))
  559.   (with-vector (data (simple-array card8 (*)))
  560.     (with-buffer-input (reply-buffer :sizes (8))
  561.       (buffer-replace data buffer-bbuf start (index+ start nitems) index))))
  562.  
  563. #-lispm
  564. (defun read-simple-array-card8-with-transform (reply-buffer nitems data transform start index)
  565.   (declare (type reply-buffer reply-buffer)
  566.        (type array-index nitems start index)
  567.        (type (simple-array card8 (*)) data))
  568.   (declare (type (function (card8) card8) transform)
  569.        #+clx-ansi-common-lisp
  570.        (dynamic-extent transform)
  571.        #+(and lispm (not clx-ansi-common-lisp))
  572.        (sys:downward-funarg transform))
  573.   (with-vector (data (simple-array card8 (*)))
  574.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  575.       (do* ((j start (index+ j 1))
  576.         (end (index+ start nitems))
  577.         (index 0 (index+ index 1)))
  578.        ((index>= j end))
  579.     (declare (type array-index j end index))
  580.     (setf (aref data j) (the card8 (funcall transform (read-card8 index))))))))
  581.  
  582. (defun read-vector-card8 (reply-buffer nitems data start index)
  583.   (declare (type reply-buffer reply-buffer)
  584.        (type array-index nitems start index)
  585.        (type vector data))
  586.   (with-vector (data vector)
  587.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  588.       (do* ((j start (index+ j 1))
  589.         (end (index+ start nitems))
  590.         (index 0 (index+ index 1)))
  591.        ((index>= j end))
  592.     (declare (type array-index j end index))
  593.     (setf (aref data j) (read-card8 index))))))
  594.  
  595. (defun read-vector-card8-with-transform (reply-buffer nitems data transform start index)
  596.   (declare (type reply-buffer reply-buffer)
  597.        (type array-index nitems start index)
  598.        (type vector data))
  599.   (declare (type (function (card8) t) transform)
  600.        #+clx-ansi-common-lisp
  601.        (dynamic-extent transform)
  602.        #+(and lispm (not clx-ansi-common-lisp))
  603.        (sys:downward-funarg transform))
  604.   (with-vector (data vector)
  605.     (with-buffer-input (reply-buffer :sizes (8) :index index)
  606.       (do* ((j start (index+ j 1))
  607.         (end (index+ start nitems))
  608.         (index 0 (index+ index 1)))
  609.        ((index>= j end))
  610.     (declare (type array-index j end index))
  611.     (setf (aref data j) (funcall transform (read-card8 index)))))))
  612.  
  613. (defun read-sequence-card8 (reply-buffer result-type nitems &optional transform data
  614.                 (start 0) (index 0))
  615.   (declare (type reply-buffer reply-buffer)
  616.        (type t result-type) ;; CL type
  617.        (type array-index nitems start index)
  618.        (type (or null sequence) data))
  619.   (declare (type (or null (function (card8) t)) transform)
  620.        #+clx-ansi-common-lisp
  621.        (dynamic-extent transform)
  622.        #+(and lispm (not clx-ansi-common-lisp))
  623.        (sys:downward-funarg transform))
  624.   (let ((result (or data (make-sequence result-type nitems))))
  625.     (typecase result
  626.       (list
  627.     (if transform 
  628.         (read-list-card8-with-transform
  629.           reply-buffer nitems result transform start index)
  630.       (read-list-card8 reply-buffer nitems result start index)))
  631.       #-lispm
  632.       ((simple-array card8 (*))
  633.        (if transform 
  634.        (read-simple-array-card8-with-transform
  635.          reply-buffer nitems result transform start index)
  636.      (read-simple-array-card8 reply-buffer nitems result start index)))
  637.       (t
  638.     (if transform 
  639.         (read-vector-card8-with-transform
  640.           reply-buffer nitems result transform start index)
  641.       (read-vector-card8 reply-buffer nitems result start index))))
  642.     result))
  643.  
  644. ;;; For now, perhaps performance it isn't worth doing better?
  645.  
  646. (defun read-sequence-int8 (reply-buffer result-type nitems &optional transform data
  647.                (start 0) (index 0))
  648.   (declare (type reply-buffer reply-buffer)
  649.        (type t result-type) ;; CL type
  650.        (type array-index nitems start index)
  651.        (type (or null sequence) data))
  652.   (declare (type (or null (function (int8) t)) transform)
  653.        #+clx-ansi-common-lisp
  654.        (dynamic-extent transform)
  655.        #+(and lispm (not clx-ansi-common-lisp))
  656.        (sys:downward-funarg transform))
  657.   (if transform 
  658.       (flet ((card8->int8->transform (v)
  659.            (declare (type card8 v))
  660.            (funcall transform (card8->int8 v))))
  661.     #+clx-ansi-common-lisp
  662.     (declare (dynamic-extent #'card8->int8->transform))
  663.     (read-sequence-card8
  664.       reply-buffer result-type nitems #'card8->int8->transform
  665.       data start index))
  666.     (read-sequence-card8
  667.       reply-buffer result-type nitems #'card8->int8
  668.       data start index)))
  669.  
  670. ;;; Reading sequences of card16's
  671.  
  672. (defun read-list-card16 (reply-buffer nitems data start index)
  673.   (declare (type reply-buffer reply-buffer)
  674.        (type array-index nitems start index)
  675.        (type list data))
  676.   (with-buffer-input (reply-buffer :sizes (16) :index index)
  677.     (do* ((j nitems (index- j 1))
  678.       (lst (nthcdr start data) (cdr lst))
  679.       (index 0 (index+ index 2)))
  680.      ((index-zerop j))
  681.       (declare (type array-index j index)
  682.            (type cons lst))
  683.       (setf (car lst) (read-card16 index)))))
  684.  
  685. (defun read-list-card16-with-transform (reply-buffer nitems data transform start index)
  686.   (declare (type reply-buffer reply-buffer)
  687.        (type array-index nitems start index)
  688.        (type list data))
  689.   (declare (type (function (card16) t) transform)
  690.        #+clx-ansi-common-lisp
  691.        (dynamic-extent transform)
  692.        #+(and lispm (not clx-ansi-common-lisp))
  693.        (sys:downward-funarg transform))
  694.   (with-buffer-input (reply-buffer :sizes (16) :index index)
  695.     (do* ((j nitems (index- j 1))
  696.       (lst (nthcdr start data) (cdr lst))
  697.       (index 0 (index+ index 2)))
  698.      ((index-zerop j))
  699.       (declare (type array-index j index)
  700.            (type cons lst))
  701.       (setf (car lst) (funcall transform (read-card16 index))))))
  702.  
  703. #-lispm
  704. (defun read-simple-array-card16 (reply-buffer nitems data start index)
  705.   (declare (type reply-buffer reply-buffer)
  706.        (type array-index nitems start index)
  707.        (type (simple-array card16 (*)) data))
  708.   (with-vector (data (simple-array card16 (*)))
  709.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  710.       #-clx-overlapping-arrays
  711.       (do* ((j start (index+ j 1))
  712.         (end (index+ start nitems))
  713.         (index 0 (index+ index 2)))
  714.        ((index>= j end))
  715.     (declare (type array-index j end index))
  716.     (setf (aref data j) (the card16 (read-card16 index))))
  717.       #+clx-overlapping-arrays
  718.       (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
  719.  
  720. #-lispm
  721. (defun read-simple-array-card16-with-transform (reply-buffer nitems data transform start index)
  722.   (declare (type reply-buffer reply-buffer)
  723.        (type array-index nitems start index)
  724.        (type (simple-array card16 (*)) data))
  725.   (declare (type (function (card16) card16) transform)
  726.        #+clx-ansi-common-lisp
  727.        (dynamic-extent transform)
  728.        #+(and lispm (not clx-ansi-common-lisp))
  729.        (sys:downward-funarg transform))
  730.   (with-vector (data (simple-array card16 (*)))
  731.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  732.       (do* ((j start (index+ j 1))
  733.         (end (index+ start nitems))
  734.         (index 0 (index+ index 2)))
  735.        ((index>= j end))
  736.     (declare (type array-index j end index))
  737.     (setf (aref data j) (the card16 (funcall transform (read-card16 index))))))))
  738.  
  739. (defun read-vector-card16 (reply-buffer nitems data start index)
  740.   (declare (type reply-buffer reply-buffer)
  741.        (type array-index nitems start index)
  742.        (type vector data))
  743.   (with-vector (data vector)
  744.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  745.       #-clx-overlapping-arrays
  746.       (do* ((j start (index+ j 1))
  747.         (end (index+ start nitems))
  748.         (index 0 (index+ index 2)))
  749.        ((index>= j end))
  750.     (declare (type array-index j end index))
  751.     (setf (aref data j) (read-card16 index)))
  752.       #+clx-overlapping-arrays
  753.       (buffer-replace data buffer-wbuf start (index+ start nitems) (index-floor index 2)))))
  754.  
  755. (defun read-vector-card16-with-transform (reply-buffer nitems data transform start index)
  756.   (declare (type reply-buffer reply-buffer)
  757.        (type array-index nitems start index)
  758.        (type vector data))
  759.   (declare (type (function (card16) t) transform)
  760.        #+clx-ansi-common-lisp
  761.        (dynamic-extent transform)
  762.        #+(and lispm (not clx-ansi-common-lisp))
  763.        (sys:downward-funarg transform))
  764.   (with-vector (data vector)
  765.     (with-buffer-input (reply-buffer :sizes (16) :index index)
  766.       (do* ((j start (index+ j 1))
  767.         (end (index+ start nitems))
  768.         (index 0 (index+ index 2)))
  769.        ((index>= j end))
  770.     (declare (type array-index j end index))
  771.     (setf (aref data j) (funcall transform (read-card16 index)))))))
  772.  
  773. (defun read-sequence-card16 (reply-buffer result-type nitems &optional transform data
  774.                  (start 0) (index 0))
  775.   (declare (type reply-buffer reply-buffer)
  776.        (type t result-type) ;; CL type
  777.        (type array-index nitems start index)
  778.        (type (or null sequence) data))
  779.   (declare (type (or null (function (card16) t)) transform)
  780.        #+clx-ansi-common-lisp
  781.        (dynamic-extent transform)
  782.        #+(and lispm (not clx-ansi-common-lisp))
  783.        (sys:downward-funarg transform))
  784.   (let ((result (or data (make-sequence result-type nitems))))
  785.     (typecase result
  786.       (list
  787.     (if transform 
  788.         (read-list-card16-with-transform reply-buffer nitems result transform start index)
  789.       (read-list-card16 reply-buffer nitems result start index)))
  790.       #-lispm
  791.       ((simple-array card16 (*))
  792.        (if transform 
  793.        (read-simple-array-card16-with-transform
  794.          reply-buffer nitems result transform start index)
  795.      (read-simple-array-card16 reply-buffer nitems result start index)))
  796.       (t
  797.     (if transform 
  798.         (read-vector-card16-with-transform
  799.           reply-buffer nitems result transform start index)
  800.       (read-vector-card16 reply-buffer nitems result start index))))
  801.     result))
  802.   
  803. ;;; For now, perhaps performance it isn't worth doing better?
  804.  
  805. (defun read-sequence-int16 (reply-buffer result-type nitems &optional transform data
  806.                 (start 0) (index 0))
  807.   (declare (type reply-buffer reply-buffer)
  808.        (type t result-type) ;; CL type
  809.        (type array-index nitems start index)
  810.        (type (or null sequence) data))
  811.   (declare (type (or null (function (int16) t)) transform)
  812.        #+clx-ansi-common-lisp
  813.        (dynamic-extent transform)
  814.        #+(and lispm (not clx-ansi-common-lisp))
  815.        (sys:downward-funarg transform))
  816.   (if transform 
  817.       (flet ((card16->int16->transform (v)
  818.            (declare (type card16 v))
  819.            (funcall transform (card16->int16 v))))
  820.     #+clx-ansi-common-lisp
  821.     (declare (dynamic-extent #'card16->int16->transform))
  822.     (read-sequence-card16
  823.       reply-buffer result-type nitems #'card16->int16->transform
  824.       data start index))
  825.     (read-sequence-card16
  826.       reply-buffer result-type nitems #'card16->int16
  827.       data start index)))
  828.  
  829. ;;; Reading sequences of card32's
  830.  
  831. (defun read-list-card32 (reply-buffer nitems data start index)
  832.   (declare (type reply-buffer reply-buffer)
  833.        (type array-index nitems start index)
  834.        (type list data))
  835.   (with-buffer-input (reply-buffer :sizes (32) :index index)
  836.     (do* ((j nitems (index- j 1))
  837.       (lst (nthcdr start data) (cdr lst))
  838.       (index 0 (index+ index 4)))
  839.      ((index-zerop j))
  840.       (declare (type array-index j index)
  841.            (type cons lst))
  842.       (setf (car lst) (read-card32 index)))))
  843.  
  844. (defun read-list-card32-with-transform (reply-buffer nitems data transform start index)
  845.   (declare (type reply-buffer reply-buffer)
  846.        (type array-index nitems start index)
  847.        (type list data))
  848.   (declare (type (function (card32) t) transform)
  849.        #+clx-ansi-common-lisp
  850.        (dynamic-extent transform)
  851.        #+(and lispm (not clx-ansi-common-lisp))
  852.        (sys:downward-funarg transform))
  853.   (with-buffer-input (reply-buffer :sizes (32) :index index)
  854.     (do* ((j nitems (index- j 1))
  855.       (lst (nthcdr start data) (cdr lst))
  856.       (index 0 (index+ index 4)))
  857.      ((index-zerop j))
  858.       (declare (type array-index j index)
  859.            (type cons lst))
  860.       (setf (car lst) (funcall transform (read-card32 index))))))
  861.  
  862. #-lispm
  863. (defun read-simple-array-card32 (reply-buffer nitems data start index)
  864.   (declare (type reply-buffer reply-buffer)
  865.        (type array-index nitems start index)
  866.        (type (simple-array card32 (*)) data))
  867.   (with-vector (data (simple-array card32 (*)))
  868.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  869.       #-clx-overlapping-arrays
  870.       (do* ((j start (index+ j 1))
  871.         (end (index+ start nitems))
  872.         (index 0 (index+ index 4)))
  873.        ((index>= j end))
  874.     (declare (type array-index j end index))
  875.     (setf (aref data j) (the card32 (read-card32 index))))
  876.       #+clx-overlapping-arrays
  877.       (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
  878.  
  879. #-lispm
  880. (defun read-simple-array-card32-with-transform (reply-buffer nitems data transform start index)
  881.   (declare (type reply-buffer reply-buffer)
  882.        (type array-index nitems start index)
  883.        (type (simple-array card32 (*)) data))
  884.   (declare (type (function (card32) card32) transform)
  885.        #+clx-ansi-common-lisp
  886.        (dynamic-extent transform)
  887.        #+(and lispm (not clx-ansi-common-lisp))
  888.        (sys:downward-funarg transform))
  889.   (with-vector (data (simple-array card32 (*)))
  890.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  891.       (do* ((j start (index+ j 1))
  892.         (end (index+ start nitems))
  893.         (index 0 (index+ index 4)))
  894.        ((index>= j end))
  895.     (declare (type array-index j end index))
  896.     (setf (aref data j) (the card32 (funcall transform (read-card32 index))))))))
  897.  
  898. (defun read-vector-card32 (reply-buffer nitems data start index)
  899.   (declare (type reply-buffer reply-buffer)
  900.        (type array-index nitems start index)
  901.        (type vector data))
  902.   (with-vector (data vector)
  903.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  904.       #-clx-overlapping-arrays
  905.       (do* ((j start (index+ j 1))
  906.         (end (index+ start nitems))
  907.         (index 0 (index+ index 4)))
  908.        ((index>= j end))
  909.     (declare (type array-index j end index))
  910.     (setf (aref data j) (read-card32 index)))
  911.       #+clx-overlapping-arrays
  912.       (buffer-replace data buffer-lbuf start (index+ start nitems) (index-floor index 4)))))
  913.  
  914. (defun read-vector-card32-with-transform (reply-buffer nitems data transform start index)
  915.   (declare (type reply-buffer reply-buffer)
  916.        (type array-index nitems start index)
  917.        (type vector data))
  918.   (declare (type (function (card32) t) transform)
  919.        #+clx-ansi-common-lisp
  920.        (dynamic-extent transform)
  921.        #+(and lispm (not clx-ansi-common-lisp))
  922.        (sys:downward-funarg transform))
  923.   (with-vector (data vector)
  924.     (with-buffer-input (reply-buffer :sizes (32) :index index)
  925.       (do* ((j start (index+ j 1))
  926.         (end (index+ start nitems))
  927.         (index 0 (index+ index 4)))
  928.        ((index>= j end))
  929.     (declare (type array-index j end index))
  930.     (setf (aref data j) (funcall transform (read-card32 index)))))))
  931.  
  932. (defun read-sequence-card32 (reply-buffer result-type nitems &optional transform data
  933.                  (start 0) (index 0))
  934.   (declare (type reply-buffer reply-buffer)
  935.        (type t result-type) ;; CL type
  936.        (type array-index nitems start index)
  937.        (type (or null sequence) data))
  938.   (declare (type (or null (function (card32) t)) transform)
  939.        #+clx-ansi-common-lisp
  940.        (dynamic-extent transform)
  941.        #+(and lispm (not clx-ansi-common-lisp))
  942.        (sys:downward-funarg transform))
  943.   (let ((result (or data (make-sequence result-type nitems))))
  944.     (typecase result
  945.       (list
  946.     (if transform 
  947.         (read-list-card32-with-transform reply-buffer nitems result transform start index)
  948.       (read-list-card32 reply-buffer nitems result start index)))
  949.       #-lispm
  950.       ((simple-array card32 (*))
  951.        (if transform 
  952.        (read-simple-array-card32-with-transform
  953.          reply-buffer nitems result transform start index)
  954.      (read-simple-array-card32 reply-buffer nitems result start index)))
  955.       (t
  956.     (if transform 
  957.         (read-vector-card32-with-transform
  958.           reply-buffer nitems result transform start index)
  959.       (read-vector-card32 reply-buffer nitems result start index))))
  960.     result))
  961.  
  962. ;;; For now, perhaps performance it isn't worth doing better?
  963.  
  964. (defun read-sequence-int32 (reply-buffer result-type nitems &optional transform data
  965.                 (start 0) (index 0))
  966.   (declare (type reply-buffer reply-buffer)
  967.        (type t result-type) ;; CL type
  968.        (type array-index nitems start index)
  969.        (type (or null sequence) data))
  970.   (declare (type (or null (function (int32) t)) transform)
  971.        #+clx-ansi-common-lisp
  972.        (dynamic-extent transform)
  973.        #+(and lispm (not clx-ansi-common-lisp))
  974.        (sys:downward-funarg transform))
  975.   (if transform 
  976.       (flet ((card32->int32->transform (v)
  977.            (declare (type card32 v))
  978.            (funcall transform (card32->int32 v))))
  979.     #+clx-ansi-common-lisp
  980.     (declare (dynamic-extent #'card32->int32->transform))
  981.     (read-sequence-card32
  982.       reply-buffer result-type nitems #'card32->int32->transform
  983.       data start index))
  984.     (read-sequence-card32
  985.       reply-buffer result-type nitems #'card32->int32
  986.       data start index)))
  987.  
  988. ;;; Writing sequences of chars
  989.  
  990. (defun write-sequence-char
  991.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  992.   (declare (type buffer buffer)
  993.        (type sequence data)
  994.        (type array-index boffset start end))
  995.   (declare (type (or null (function (t) character)) transform)
  996.        #+clx-ansi-common-lisp
  997.        (dynamic-extent transform)
  998.        #+(and lispm (not clx-ansi-common-lisp))
  999.        (sys:downward-funarg transform))
  1000.   (if transform 
  1001.       (flet ((transform->char->card8 (x)
  1002.            (char->card8 (the character (funcall transform x)))))
  1003.     #+clx-ansi-common-lisp
  1004.     (declare (dynamic-extent #'transform->char->card8))
  1005.     (write-sequence-card8
  1006.       buffer boffset data start end #'transform->char->card8))
  1007.     (write-sequence-card8 buffer boffset data start end #'char->card8)))
  1008.  
  1009. ;;; Writing sequences of card8's
  1010.  
  1011. (defun write-list-card8 (buffer boffset data start end)
  1012.   (declare (type buffer buffer)
  1013.        (type list data)
  1014.        (type array-index boffset start end))
  1015.   (writing-buffer-chunks card8
  1016.              ((lst (nthcdr start data)))
  1017.              ((type list lst))
  1018.     (dotimes (j chunk)
  1019.       (declare (type array-index j))
  1020.       #-ti (write-card8 j (pop lst))        ;TI Compiler bug
  1021.       #+ti (setf (aref buffer-bbuf (index+ buffer-boffset j)) (pop lst))
  1022.       ))
  1023.   nil)
  1024.  
  1025. (defun write-list-card8-with-transform (buffer boffset data start end transform)
  1026.   (declare (type buffer buffer)
  1027.        (type list data)
  1028.        (type array-index boffset start end))
  1029.   (declare (type (function (t) card8) transform)
  1030.        #+clx-ansi-common-lisp
  1031.        (dynamic-extent transform)
  1032.        #+(and lispm (not clx-ansi-common-lisp))
  1033.        (sys:downward-funarg transform))
  1034.   (writing-buffer-chunks card8
  1035.              ((lst (nthcdr start data)))
  1036.              ((type list lst))
  1037.     (dotimes (j chunk)
  1038.       (declare (type array-index j))
  1039.       (write-card8 j (funcall transform (pop lst)))))
  1040.   nil)
  1041.  
  1042. ;;; Should really write directly from data, instead of into the buffer first
  1043. #-lispm
  1044. (defun write-simple-array-card8 (buffer boffset data start end)
  1045.   (declare (type buffer buffer)
  1046.        (type (simple-array card8 (*)) data)
  1047.        (type array-index boffset start end))
  1048.   (with-vector (data (simple-array card8 (*)))
  1049.     (writing-buffer-chunks card8
  1050.                ((index start (index+ index chunk)))
  1051.                ((type array-index index))
  1052.       (buffer-replace buffer-bbuf data
  1053.               buffer-boffset
  1054.               (index+ buffer-boffset chunk)
  1055.               index)))
  1056.   nil)
  1057.  
  1058. #-lispm
  1059. (defun write-simple-array-card8-with-transform (buffer boffset data start end transform)
  1060.   (declare (type buffer buffer)
  1061.        (type (simple-array card8 (*)) data)
  1062.        (type array-index boffset start end))
  1063.   (declare (type (function (card8) card8) transform)
  1064.        #+clx-ansi-common-lisp
  1065.        (dynamic-extent transform)
  1066.        #+(and lispm (not clx-ansi-common-lisp))
  1067.        (sys:downward-funarg transform))
  1068.   (with-vector (data (simple-array card8 (*)))
  1069.     (writing-buffer-chunks card8
  1070.                ((index start))
  1071.                ((type array-index index))
  1072.       (dotimes (j chunk)
  1073.     (declare (type array-index j))
  1074.     (write-card8 j (funcall transform (aref data index)))
  1075.     (setq index (index+ index 1)))))
  1076.   nil)
  1077.  
  1078. (defun write-vector-card8 (buffer boffset data start end)
  1079.   (declare (type buffer buffer)
  1080.        (type vector data)
  1081.        (type array-index boffset start end))
  1082.   (with-vector (data vector)
  1083.     (writing-buffer-chunks card8
  1084.                ((index start))
  1085.                ((type array-index index))
  1086.       (dotimes (j chunk)
  1087.     (declare (type array-index j))
  1088.     (write-card8 j (aref data index))
  1089.     (setq index (index+ index 1)))))
  1090.   nil)
  1091.  
  1092. (defun write-vector-card8-with-transform (buffer boffset data start end transform)
  1093.   (declare (type buffer buffer)
  1094.        (type vector data)
  1095.        (type array-index boffset start end))
  1096.   (declare (type (function (t) card8) transform)
  1097.        #+clx-ansi-common-lisp
  1098.        (dynamic-extent transform)
  1099.        #+(and lispm (not clx-ansi-common-lisp))
  1100.        (sys:downward-funarg transform))
  1101.   (with-vector (data vector)
  1102.     (writing-buffer-chunks card8
  1103.                ((index start))
  1104.                ((type array-index index))
  1105.       (dotimes (j chunk)
  1106.     (declare (type array-index j))
  1107.     (write-card8 j (funcall transform (aref data index)))
  1108.     (setq index (index+ index 1)))))
  1109.   nil)
  1110.  
  1111. (defun write-sequence-card8
  1112.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1113.   (declare (type buffer buffer)
  1114.        (type sequence data)
  1115.        (type array-index boffset start end))
  1116.   (declare (type (or null (function (t) card8)) transform)
  1117.        #+clx-ansi-common-lisp
  1118.        (dynamic-extent transform)
  1119.        #+(and lispm (not clx-ansi-common-lisp))
  1120.        (sys:downward-funarg transform))
  1121.   (typecase data
  1122.     (list
  1123.       (if transform
  1124.       (write-list-card8-with-transform buffer boffset data start end transform)
  1125.       (write-list-card8 buffer boffset data start end)))
  1126.     #-lispm
  1127.     ((simple-array card8 (*))
  1128.      (if transform
  1129.      (write-simple-array-card8-with-transform buffer boffset data start end transform)
  1130.      (write-simple-array-card8 buffer boffset data start end)))
  1131.     (t
  1132.       (if transform
  1133.       (write-vector-card8-with-transform buffer boffset data start end transform)
  1134.       (write-vector-card8 buffer boffset data start end)))))
  1135.  
  1136. ;;; For now, perhaps performance it isn't worth doing better?
  1137.  
  1138. (defun write-sequence-int8
  1139.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1140.   (declare (type buffer buffer)
  1141.        (type sequence data)
  1142.        (type array-index boffset start end))
  1143.   (declare (type (or null (function (t) int8)) transform)
  1144.        #+clx-ansi-common-lisp
  1145.        (dynamic-extent transform)
  1146.        #+(and lispm (not clx-ansi-common-lisp))
  1147.        (sys:downward-funarg transform))
  1148.   (if transform 
  1149.       (flet ((transform->int8->card8 (x)
  1150.            (int8->card8 (the int8 (funcall transform x)))))
  1151.     #+clx-ansi-common-lisp
  1152.     (declare (dynamic-extent #'transform->int8->card8))
  1153.     (write-sequence-card8
  1154.       buffer boffset data start end #'transform->int8->card8))
  1155.       (write-sequence-card8 buffer boffset data start end #'int8->card8)))
  1156.  
  1157. ;;; Writing sequences of card16's
  1158.  
  1159. (defun write-list-card16 (buffer boffset data start end)
  1160.   (declare (type buffer buffer)
  1161.        (type list data)
  1162.        (type array-index boffset start end))
  1163.   (writing-buffer-chunks card16
  1164.              ((lst (nthcdr start data)))
  1165.              ((type list lst))
  1166.     ;; Depends upon the chunks being an even multiple of card16's big
  1167.     (do ((j 0 (index+ j 2)))
  1168.     ((index>= j chunk))
  1169.       (declare (type array-index j))
  1170.       (write-card16 j (pop lst))))
  1171.   nil)
  1172.  
  1173. (defun write-list-card16-with-transform (buffer boffset data start end transform)
  1174.   (declare (type buffer buffer)
  1175.        (type list data)
  1176.        (type array-index boffset start end))
  1177.   (declare (type (function (t) card16) transform)
  1178.        #+clx-ansi-common-lisp
  1179.        (dynamic-extent transform)
  1180.        #+(and lispm (not clx-ansi-common-lisp))
  1181.        (sys:downward-funarg transform))
  1182.   (writing-buffer-chunks card16
  1183.              ((lst (nthcdr start data)))
  1184.              ((type list lst))
  1185.     ;; Depends upon the chunks being an even multiple of card16's big
  1186.     (do ((j 0 (index+ j 2)))
  1187.     ((index>= j chunk))
  1188.       (declare (type array-index j))
  1189.       (write-card16 j (funcall transform (pop lst)))))
  1190.   nil)
  1191.  
  1192. #-lispm
  1193. (defun write-simple-array-card16 (buffer boffset data start end)
  1194.   (declare (type buffer buffer)
  1195.        (type (simple-array card16 (*)) data)
  1196.        (type array-index boffset start end))
  1197.   (with-vector (data (simple-array card16 (*)))
  1198.     (writing-buffer-chunks card16
  1199.                ((index start))
  1200.                ((type array-index index))
  1201.       ;; Depends upon the chunks being an even multiple of card16's big
  1202.       (do ((j 0 (index+ j 2)))
  1203.       ((index>= j chunk))
  1204.     (declare (type array-index j))
  1205.     (write-card16 j (aref data index))
  1206.     (setq index (index+ index 1)))
  1207.       ;; overlapping case
  1208.       (let ((length (floor chunk 2)))
  1209.     (buffer-replace buffer-wbuf data
  1210.             buffer-woffset
  1211.             (index+ buffer-woffset length)
  1212.             index)
  1213.     (setq index (index+ index length)))))
  1214.   nil)
  1215.  
  1216. #-lispm
  1217. (defun write-simple-array-card16-with-transform (buffer boffset data start end transform)
  1218.   (declare (type buffer buffer)
  1219.        (type (simple-array card16 (*)) data)
  1220.        (type array-index boffset start end))
  1221.   (declare (type (function (card16) card16) transform)
  1222.        #+clx-ansi-common-lisp
  1223.        (dynamic-extent transform)
  1224.        #+(and lispm (not clx-ansi-common-lisp))
  1225.        (sys:downward-funarg transform))
  1226.   (with-vector (data (simple-array card16 (*)))
  1227.     (writing-buffer-chunks card16
  1228.                ((index start))
  1229.                ((type array-index index))
  1230.       ;; Depends upon the chunks being an even multiple of card16's big
  1231.       (do ((j 0 (index+ j 2)))
  1232.       ((index>= j chunk))
  1233.     (declare (type array-index j))
  1234.     (write-card16 j (funcall transform (aref data index)))
  1235.     (setq index (index+ index 1)))))
  1236.   nil)
  1237.  
  1238. (defun write-vector-card16 (buffer boffset data start end)
  1239.   (declare (type buffer buffer)
  1240.        (type vector data)
  1241.        (type array-index boffset start end))
  1242.   (with-vector (data vector)
  1243.     (writing-buffer-chunks card16
  1244.                ((index start))
  1245.                ((type array-index index))
  1246.       ;; Depends upon the chunks being an even multiple of card16's big
  1247.       (do ((j 0 (index+ j 2)))
  1248.       ((index>= j chunk))
  1249.     (declare (type array-index j))
  1250.     (write-card16 j (aref data index))
  1251.     (setq index (index+ index 1)))
  1252.       ;; overlapping case
  1253.       (let ((length (floor chunk 2)))
  1254.     (buffer-replace buffer-wbuf data
  1255.             buffer-woffset
  1256.             (index+ buffer-woffset length)
  1257.             index)
  1258.     (setq index (index+ index length)))))
  1259.   nil)
  1260.  
  1261. (defun write-vector-card16-with-transform (buffer boffset data start end transform)
  1262.   (declare (type buffer buffer)
  1263.        (type vector data)
  1264.        (type array-index boffset start end))
  1265.   (declare (type (function (t) card16) transform)
  1266.        #+clx-ansi-common-lisp
  1267.        (dynamic-extent transform)
  1268.        #+(and lispm (not clx-ansi-common-lisp))
  1269.        (sys:downward-funarg transform))
  1270.   (with-vector (data vector)
  1271.     (writing-buffer-chunks card16
  1272.                ((index start))
  1273.                ((type array-index index))
  1274.       ;; Depends upon the chunks being an even multiple of card16's big
  1275.       (do ((j 0 (index+ j 2)))
  1276.       ((index>= j chunk))
  1277.     (declare (type array-index j))
  1278.     (write-card16 j (funcall transform (aref data index)))
  1279.     (setq index (index+ index 1)))))
  1280.   nil)
  1281.  
  1282. (defun write-sequence-card16
  1283.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1284.   (declare (type buffer buffer)
  1285.        (type sequence data)
  1286.        (type array-index boffset start end))
  1287.   (declare (type (or null (function (t) card16)) transform)
  1288.        #+clx-ansi-common-lisp
  1289.        (dynamic-extent transform)
  1290.        #+(and lispm (not clx-ansi-common-lisp))
  1291.        (sys:downward-funarg transform))
  1292.   (typecase data
  1293.     (list
  1294.       (if transform
  1295.       (write-list-card16-with-transform buffer boffset data start end transform)
  1296.       (write-list-card16 buffer boffset data start end)))
  1297.     #-lispm
  1298.     ((simple-array card16 (*))
  1299.      (if transform
  1300.      (write-simple-array-card16-with-transform buffer boffset data start end transform)
  1301.      (write-simple-array-card16 buffer boffset data start end)))
  1302.     (t
  1303.       (if transform
  1304.       (write-vector-card16-with-transform buffer boffset data start end transform)
  1305.       (write-vector-card16 buffer boffset data start end)))))
  1306.  
  1307. ;;; Writing sequences of int16's
  1308.  
  1309. (defun write-list-int16 (buffer boffset data start end)
  1310.   (declare (type buffer buffer)
  1311.        (type list data)
  1312.        (type array-index boffset start end))
  1313.   (writing-buffer-chunks int16
  1314.              ((lst (nthcdr start data)))
  1315.              ((type list lst))
  1316.     ;; Depends upon the chunks being an even multiple of int16's big
  1317.     (do ((j 0 (index+ j 2)))
  1318.     ((index>= j chunk))
  1319.       (declare (type array-index j))
  1320.       (write-int16 j (pop lst))))
  1321.   nil)
  1322.  
  1323. (defun write-list-int16-with-transform (buffer boffset data start end transform)
  1324.   (declare (type buffer buffer)
  1325.        (type list data)
  1326.        (type array-index boffset start end))
  1327.   (declare (type (function (t) int16) transform)
  1328.        #+clx-ansi-common-lisp
  1329.        (dynamic-extent transform)
  1330.        #+(and lispm (not clx-ansi-common-lisp))
  1331.        (sys:downward-funarg transform))
  1332.   (writing-buffer-chunks int16
  1333.              ((lst (nthcdr start data)))
  1334.              ((type list lst))
  1335.     ;; Depends upon the chunks being an even multiple of int16's big
  1336.     (do ((j 0 (index+ j 2)))
  1337.     ((index>= j chunk))
  1338.       (declare (type array-index j))
  1339.       (write-int16 j (funcall transform (pop lst)))))
  1340.   nil)
  1341.  
  1342. #-lispm
  1343. (defun write-simple-array-int16 (buffer boffset data start end)
  1344.   (declare (type buffer buffer)
  1345.        (type (simple-array int16 (*)) data)
  1346.        (type array-index boffset start end))
  1347.   (with-vector (data (simple-array int16 (*)))
  1348.     (writing-buffer-chunks int16
  1349.                ((index start))
  1350.                ((type array-index index))
  1351.       ;; Depends upon the chunks being an even multiple of int16's big
  1352.       (do ((j 0 (index+ j 2)))
  1353.       ((index>= j chunk))
  1354.     (declare (type array-index j))
  1355.     (write-int16 j (aref data index))
  1356.     (setq index (index+ index 1)))
  1357.       ;; overlapping case
  1358.       (let ((length (floor chunk 2)))
  1359.     (buffer-replace buffer-wbuf data
  1360.             buffer-woffset
  1361.             (index+ buffer-woffset length)
  1362.             index)
  1363.     (setq index (index+ index length)))))
  1364.   nil)
  1365.  
  1366. #-lispm
  1367. (defun write-simple-array-int16-with-transform (buffer boffset data start end transform)
  1368.   (declare (type buffer buffer)
  1369.        (type (simple-array int16 (*)) data)
  1370.        (type array-index boffset start end))
  1371.   (declare (type (function (int16) int16) transform)
  1372.        #+clx-ansi-common-lisp
  1373.        (dynamic-extent transform)
  1374.        #+(and lispm (not clx-ansi-common-lisp))
  1375.        (sys:downward-funarg transform))
  1376.   (with-vector (data (simple-array int16 (*)))
  1377.     (writing-buffer-chunks int16
  1378.                ((index start))
  1379.                ((type array-index index))
  1380.       ;; Depends upon the chunks being an even multiple of int16's big
  1381.       (do ((j 0 (index+ j 2)))
  1382.       ((index>= j chunk))
  1383.     (declare (type array-index j))
  1384.     (write-int16 j (funcall transform (aref data index)))
  1385.     (setq index (index+ index 1)))))
  1386.   nil)
  1387.  
  1388. (defun write-vector-int16 (buffer boffset data start end)
  1389.   (declare (type buffer buffer)
  1390.        (type vector data)
  1391.        (type array-index boffset start end))
  1392.   (with-vector (data vector)
  1393.     (writing-buffer-chunks int16
  1394.                ((index start))
  1395.                ((type array-index index))
  1396.       ;; Depends upon the chunks being an even multiple of int16's big
  1397.       (do ((j 0 (index+ j 2)))
  1398.       ((index>= j chunk))
  1399.     (declare (type array-index j))
  1400.     (write-int16 j (aref data index))
  1401.     (setq index (index+ index 1)))
  1402.       ;; overlapping case
  1403.       (let ((length (floor chunk 2)))
  1404.     (buffer-replace buffer-wbuf data
  1405.             buffer-woffset
  1406.             (index+ buffer-woffset length)
  1407.             index)
  1408.     (setq index (index+ index length)))))
  1409.   nil)
  1410.  
  1411. (defun write-vector-int16-with-transform (buffer boffset data start end transform)
  1412.   (declare (type buffer buffer)
  1413.        (type vector data)
  1414.        (type array-index boffset start end))
  1415.   (declare (type (function (t) int16) transform)
  1416.        #+clx-ansi-common-lisp
  1417.        (dynamic-extent transform)
  1418.        #+(and lispm (not clx-ansi-common-lisp))
  1419.        (sys:downward-funarg transform))
  1420.   (with-vector (data vector)
  1421.     (writing-buffer-chunks int16
  1422.                ((index start))
  1423.                ((type array-index index))
  1424.       ;; Depends upon the chunks being an even multiple of int16's big
  1425.       (do ((j 0 (index+ j 2)))
  1426.       ((index>= j chunk))
  1427.     (declare (type array-index j))
  1428.     (write-int16 j (funcall transform (aref data index)))
  1429.     (setq index (index+ index 1)))))
  1430.   nil)
  1431.  
  1432. (defun write-sequence-int16
  1433.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1434.   (declare (type buffer buffer)
  1435.        (type sequence data)
  1436.        (type array-index boffset start end))
  1437.   (declare (type (or null (function (t) int16)) transform)
  1438.        #+clx-ansi-common-lisp
  1439.        (dynamic-extent transform)
  1440.        #+(and lispm (not clx-ansi-common-lisp))
  1441.        (sys:downward-funarg transform))
  1442.   (typecase data
  1443.     (list
  1444.       (if transform
  1445.       (write-list-int16-with-transform buffer boffset data start end transform)
  1446.       (write-list-int16 buffer boffset data start end)))
  1447.     #-lispm
  1448.     ((simple-array int16 (*))
  1449.      (if transform
  1450.      (write-simple-array-int16-with-transform buffer boffset data start end transform)
  1451.      (write-simple-array-int16 buffer boffset data start end)))
  1452.     (t
  1453.       (if transform
  1454.       (write-vector-int16-with-transform buffer boffset data start end transform)
  1455.       (write-vector-int16 buffer boffset data start end)))))
  1456.  
  1457. ;;; Writing sequences of card32's
  1458.  
  1459. (defun write-list-card32 (buffer boffset data start end)
  1460.   (declare (type buffer buffer)
  1461.        (type list data)
  1462.        (type array-index boffset start end))
  1463.   (writing-buffer-chunks card32
  1464.              ((lst (nthcdr start data)))
  1465.              ((type list lst))
  1466.     ;; Depends upon the chunks being an even multiple of card32's big
  1467.     (do ((j 0 (index+ j 4)))
  1468.     ((index>= j chunk))
  1469.       (declare (type array-index j))
  1470.       (write-card32 j (pop lst))))
  1471.   nil)
  1472.  
  1473. (defun write-list-card32-with-transform (buffer boffset data start end transform)
  1474.   (declare (type buffer buffer)
  1475.        (type list data)
  1476.        (type array-index boffset start end))
  1477.   (declare (type (function (t) card32) transform)
  1478.        #+clx-ansi-common-lisp
  1479.        (dynamic-extent transform)
  1480.        #+(and lispm (not clx-ansi-common-lisp))
  1481.        (sys:downward-funarg transform))
  1482.   (writing-buffer-chunks card32
  1483.              ((lst (nthcdr start data)))
  1484.              ((type list lst))
  1485.     ;; Depends upon the chunks being an even multiple of card32's big
  1486.     (do ((j 0 (index+ j 4)))
  1487.     ((index>= j chunk))
  1488.       (declare (type array-index j))
  1489.       (write-card32 j (funcall transform (pop lst)))))
  1490.   nil)
  1491.  
  1492. #-lispm
  1493. (defun write-simple-array-card32 (buffer boffset data start end)
  1494.   (declare (type buffer buffer)
  1495.        (type (simple-array card32 (*)) data)
  1496.        (type array-index boffset start end))
  1497.   (with-vector (data (simple-array card32 (*)))
  1498.     (writing-buffer-chunks card32
  1499.                ((index start))
  1500.                ((type array-index index))
  1501.       ;; Depends upon the chunks being an even multiple of card32's big
  1502.       (do ((j 0 (index+ j 4)))
  1503.       ((index>= j chunk))
  1504.     (declare (type array-index j))
  1505.     (write-card32 j (aref data index))
  1506.     (setq index (index+ index 1)))
  1507.       ;; overlapping case
  1508.       (let ((length (floor chunk 4)))
  1509.     (buffer-replace buffer-lbuf data
  1510.             buffer-loffset
  1511.             (index+ buffer-loffset length)
  1512.             index)
  1513.     (setq index (index+ index length)))))
  1514.   nil)
  1515.  
  1516. #-lispm
  1517. (defun write-simple-array-card32-with-transform (buffer boffset data start end transform)
  1518.   (declare (type buffer buffer)
  1519.        (type (simple-array card32 (*)) data)
  1520.        (type array-index boffset start end))
  1521.   (declare (type (function (card32) card32) transform)
  1522.        #+clx-ansi-common-lisp
  1523.        (dynamic-extent transform)
  1524.        #+(and lispm (not clx-ansi-common-lisp))
  1525.        (sys:downward-funarg transform))
  1526.   (with-vector (data (simple-array card32 (*)))
  1527.     (writing-buffer-chunks card32
  1528.                ((index start))
  1529.                ((type array-index index))
  1530.       ;; Depends upon the chunks being an even multiple of card32's big
  1531.       (do ((j 0 (index+ j 4)))
  1532.       ((index>= j chunk))
  1533.     (declare (type array-index j))
  1534.     (write-card32 j (funcall transform (aref data index)))
  1535.     (setq index (index+ index 1)))))
  1536.   nil)
  1537.  
  1538. (defun write-vector-card32 (buffer boffset data start end)
  1539.   (declare (type buffer buffer)
  1540.        (type vector data)
  1541.        (type array-index boffset start end))
  1542.   (with-vector (data vector)
  1543.     (writing-buffer-chunks card32
  1544.                ((index start))
  1545.                ((type array-index index))
  1546.       ;; Depends upon the chunks being an even multiple of card32's big
  1547.       (do ((j 0 (index+ j 4)))
  1548.       ((index>= j chunk))
  1549.     (declare (type array-index j))
  1550.     (write-card32 j (aref data index))
  1551.     (setq index (index+ index 1)))
  1552.       ;; overlapping case
  1553.       (let ((length (floor chunk 4)))
  1554.     (buffer-replace buffer-lbuf data
  1555.             buffer-loffset
  1556.             (index+ buffer-loffset length)
  1557.             index)
  1558.     (setq index (index+ index length)))))
  1559.   nil)
  1560.  
  1561. (defun write-vector-card32-with-transform (buffer boffset data start end transform)
  1562.   (declare (type buffer buffer)
  1563.        (type vector data)
  1564.        (type array-index boffset start end))
  1565.   (declare (type (function (t) card32) transform)
  1566.        #+clx-ansi-common-lisp
  1567.        (dynamic-extent transform)
  1568.        #+(and lispm (not clx-ansi-common-lisp))
  1569.        (sys:downward-funarg transform))
  1570.   (with-vector (data vector)
  1571.     (writing-buffer-chunks card32
  1572.                ((index start))
  1573.                ((type array-index index))
  1574.       ;; Depends upon the chunks being an even multiple of card32's big
  1575.       (do ((j 0 (index+ j 4)))
  1576.       ((index>= j chunk))
  1577.     (declare (type array-index j))
  1578.     (write-card32 j (funcall transform (aref data index)))
  1579.     (setq index (index+ index 1)))))
  1580.   nil)
  1581.  
  1582. (defun write-sequence-card32
  1583.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1584.   (declare (type buffer buffer)
  1585.        (type sequence data)
  1586.        (type array-index boffset start end))
  1587.   (declare (type (or null (function (t) card32)) transform)
  1588.        #+clx-ansi-common-lisp
  1589.        (dynamic-extent transform)
  1590.        #+(and lispm (not clx-ansi-common-lisp))
  1591.        (sys:downward-funarg transform))
  1592.   (typecase data
  1593.     (list
  1594.       (if transform
  1595.       (write-list-card32-with-transform buffer boffset data start end transform)
  1596.       (write-list-card32 buffer boffset data start end)))
  1597.     #-lispm
  1598.     ((simple-array card32 (*))
  1599.      (if transform
  1600.      (write-simple-array-card32-with-transform buffer boffset data start end transform)
  1601.      (write-simple-array-card32 buffer boffset data start end)))
  1602.     (t
  1603.       (if transform
  1604.       (write-vector-card32-with-transform buffer boffset data start end transform)
  1605.       (write-vector-card32 buffer boffset data start end)))))
  1606.  
  1607. ;;; For now, perhaps performance it isn't worth doing better?
  1608.  
  1609. (defun write-sequence-int32
  1610.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1611.   (declare (type buffer buffer)
  1612.        (type sequence data)
  1613.        (type array-index boffset start end))
  1614.   (declare (type (or null (function (t) int32)) transform)
  1615.        #+clx-ansi-common-lisp
  1616.        (dynamic-extent transform)
  1617.        #+(and lispm (not clx-ansi-common-lisp))
  1618.        (sys:downward-funarg transform))
  1619.   (if transform 
  1620.       (flet ((transform->int32->card32 (x)
  1621.            (int32->card32 (the int32 (funcall transform x)))))
  1622.     #+clx-ansi-common-lisp
  1623.     (declare (dynamic-extent #'transform->int32->card32))
  1624.     (write-sequence-card32
  1625.       buffer boffset data start end #'transform->int32->card32))
  1626.     (write-sequence-card32 buffer boffset data start end #'int32->card32)))
  1627.  
  1628. (defun read-bitvector256 (buffer-bbuf boffset data)
  1629.   (declare (type buffer-bytes buffer-bbuf)
  1630.        (type array-index boffset)
  1631.        (type (or null (simple-bit-vector 256)) data))
  1632.   (let ((result (or data (make-array 256 :element-type 'bit :initial-element 0))))
  1633.     (declare (type (simple-bit-vector 256) result)
  1634.          (array-register result))
  1635.     (do ((i (index+ boffset 1) (index+ i 1)) ;; Skip first byte
  1636.      (j 8 (index+ j 8)))
  1637.     ((index>= j 256))
  1638.       (declare (type array-index i j))
  1639.       (do ((byte (aref-card8 buffer-bbuf i) (index-ash byte -1))
  1640.        (k j (index+ k 1)))
  1641.       ((zerop byte)
  1642.        (when data ;; Clear uninitialized bits in data
  1643.          (do ((end (index+ j 8)))
  1644.          ((index= k end))
  1645.            (declare (type array-index end))
  1646.            (setf (aref result k) 0)
  1647.            (index-incf k))))
  1648.     (declare (type array-index k)
  1649.          (type card8 byte))
  1650.     (setf (aref result k) (the bit (logand byte 1)))))
  1651.     result))
  1652.  
  1653. (defun write-bitvector256 (buffer boffset map)
  1654.   (declare (type buffer buffer)
  1655.        (type array-index boffset)
  1656.        (type (simple-array bit (*)) map))
  1657.   (with-buffer-output (buffer :index boffset :sizes 8)
  1658.     (do* ((i (index+ buffer-boffset 1) (index+ i 1))    ; Skip first byte
  1659.       (j 8 (index+ j 8)))        
  1660.      ((index>= j 256))
  1661.       (declare (type array-index i j))
  1662.       (do ((byte 0)
  1663.        (bit (index+ j 7) (index- bit 1)))
  1664.       ((index< bit j)
  1665.        (aset-card8 byte buffer-bbuf i))
  1666.     (declare (type array-index bit)
  1667.          (type card8 byte))
  1668.     (setq byte (the card8 (logior (the card8 (ash byte 1)) (aref map bit))))))))
  1669.  
  1670. ;;; Writing sequences of char2b's
  1671.  
  1672. (defun write-list-char2b (buffer boffset data start end)
  1673.   (declare (type buffer buffer)
  1674.        (type list data)
  1675.        (type array-index boffset start end))
  1676.   (writing-buffer-chunks card16
  1677.              ((lst (nthcdr start data)))
  1678.              ((type list lst))
  1679.     (do ((j 0 (index+ j 2)))
  1680.     ((index>= j (1- chunk)) (setf chunk j))
  1681.       (declare (type array-index j))
  1682.       (write-char2b j (pop lst))))
  1683.   nil)
  1684.  
  1685. (defun write-list-char2b-with-transform (buffer boffset data start end transform)
  1686.   (declare (type buffer buffer)
  1687.        (type list data)
  1688.        (type array-index boffset start end))
  1689.   (declare (type (function (t) card16) transform)
  1690.        #+clx-ansi-common-lisp
  1691.        (dynamic-extent transform)
  1692.        #+(and lispm (not clx-ansi-common-lisp))
  1693.        (sys:downward-funarg transform))
  1694.   (writing-buffer-chunks card16
  1695.              ((lst (nthcdr start data)))
  1696.              ((type list lst))
  1697.     (do ((j 0 (index+ j 2)))
  1698.     ((index>= j (1- chunk)) (setf chunk j))
  1699.       (declare (type array-index j))
  1700.       (write-char2b j (funcall transform (pop lst)))))
  1701.   nil)
  1702.  
  1703. #-lispm
  1704. (defun write-simple-array-char2b (buffer boffset data start end)
  1705.   (declare (type buffer buffer)
  1706.        (type (simple-array card16 (*)) data)
  1707.        (type array-index boffset start end))
  1708.   (with-vector (data (simple-array card16 (*)))
  1709.     (writing-buffer-chunks card16
  1710.                ((index start))
  1711.                ((type array-index index))
  1712.       (do ((j 0 (index+ j 2)))
  1713.       ((index>= j (1- chunk)) (setf chunk j))
  1714.     (declare (type array-index j))
  1715.     (write-char2b j (aref data index))
  1716.     (setq index (index+ index 1)))))
  1717.   nil)
  1718.  
  1719. #-lispm
  1720. (defun write-simple-array-char2b-with-transform (buffer boffset data start end transform)
  1721.   (declare (type buffer buffer)
  1722.        (type (simple-array card16 (*)) data)
  1723.        (type array-index boffset start end))
  1724.   (declare (type (function (card16) card16) transform)
  1725.        #+clx-ansi-common-lisp
  1726.        (dynamic-extent transform)
  1727.        #+(and lispm (not clx-ansi-common-lisp))
  1728.        (sys:downward-funarg transform))
  1729.   (with-vector (data (simple-array card16 (*)))
  1730.     (writing-buffer-chunks card16
  1731.                ((index start))
  1732.                ((type array-index index))
  1733.       (do ((j 0 (index+ j 2)))
  1734.       ((index>= j (1- chunk)) (setf chunk j))
  1735.     (declare (type array-index j))
  1736.     (write-char2b j (funcall transform (aref data index)))
  1737.     (setq index (index+ index 1)))))
  1738.   nil)
  1739.  
  1740. (defun write-vector-char2b (buffer boffset data start end)
  1741.   (declare (type buffer buffer)
  1742.        (type vector data)
  1743.        (type array-index boffset start end))
  1744.   (with-vector (data vector)
  1745.     (writing-buffer-chunks card16
  1746.                ((index start))
  1747.                ((type array-index index))
  1748.       (do ((j 0 (index+ j 2)))
  1749.       ((index>= j (1- chunk)) (setf chunk j))
  1750.     (declare (type array-index j))
  1751.     (write-char2b j (aref data index))
  1752.     (setq index (index+ index 1)))))
  1753.   nil)
  1754.  
  1755. (defun write-vector-char2b-with-transform (buffer boffset data start end transform)
  1756.   (declare (type buffer buffer)
  1757.        (type vector data)
  1758.        (type array-index boffset start end))
  1759.   (declare (type (function (t) card16) transform)
  1760.        #+clx-ansi-common-lisp
  1761.        (dynamic-extent transform)
  1762.        #+(and lispm (not clx-ansi-common-lisp))
  1763.        (sys:downward-funarg transform))
  1764.   (with-vector (data vector)
  1765.     (writing-buffer-chunks card16
  1766.                ((index start))
  1767.                ((type array-index index))
  1768.       (do ((j 0 (index+ j 2)))
  1769.       ((index>= j (1- chunk)) (setf chunk j))
  1770.     (declare (type array-index j))
  1771.     (write-char2b j (funcall transform (aref data index)))
  1772.     (setq index (index+ index 1)))))
  1773.   nil)
  1774.  
  1775. (defun write-sequence-char2b
  1776.        (buffer boffset data &optional (start 0) (end (length data)) transform)
  1777.   (declare (type buffer buffer)
  1778.        (type sequence data)
  1779.        (type array-index boffset start end))
  1780.   (declare (type (or null (function (t) card16)) transform)
  1781.        #+clx-ansi-common-lisp
  1782.        (dynamic-extent transform)
  1783.        #+(and lispm (not clx-ansi-common-lisp))
  1784.        (sys:downward-funarg transform))
  1785.   (typecase data
  1786.     (list
  1787.       (if transform
  1788.       (write-list-char2b-with-transform buffer boffset data start end transform)
  1789.       (write-list-char2b buffer boffset data start end)))
  1790.     #-lispm
  1791.     ((simple-array card16 (*))
  1792.      (if transform
  1793.      (write-simple-array-char2b-with-transform buffer boffset data start end transform)
  1794.      (write-simple-array-char2b buffer boffset data start end)))
  1795.     (t
  1796.       (if transform
  1797.       (write-vector-char2b-with-transform buffer boffset data start end transform)
  1798.       (write-vector-char2b buffer boffset data start end)))))
  1799.  
  1800.